home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Atari Mega Archive 1
/
Atari Mega Archive - Volume 1.iso
/
language
/
examples.zoo
/
misc
/
heapsort.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1991-10-22
|
2KB
|
51 lines
; Eine Sortierfunktion, sortiert eine Liste.
; Für list destruktiv.
; comparefun realisiert eine Totalordnung: -1 oder 0 oder +1 als Ergebnis.
; Dabei gelten zwei Listenelemente als gleich, wenn comparefun 0 liefert.
(defun sort-list (list comparefun &key (key #'identity))
; Methode: Heapsort.
; Ein Array A[0..n-1], bei dem stets A[k]>=A[2k+1] und A[k]>=A[2k+2] gilt,
; heißt "Heap".
(let* ((A (coerce list 'simple-vector))
(n (length A)))
(macrolet ((adjust (m n)
; Sei A[m+1..n-1] in Heap-Form. Danach ist auch A[m..n-1]
; in Heap-Form. Maximal O(log n) Operationen.
`(let* ((j ,m) k)
(loop
(setq k (+ j j 1))
(when (>= k ,n) (return))
(let ((k1 (+ k 1)))
(when (and (< k1 ,n)
(minusp (funcall comparefun (funcall key (aref A k))
(funcall key (aref A k1))
) ) )
(setq k k1)
) )
(when (minusp (funcall comparefun (funcall key (aref A j))
(funcall key (aref A k))
) )
(rotatef (aref A j) (aref A k))
)
(setq j k)
) )
))
; Array in Form eines Heap bringen:
(do ((jj (1- (ash n -1)) (1- jj)))
((minusp jj))
(adjust jj n)
)
; Nacheinander das jeweils verbleibende größte Element (Position 0)
; extrahieren, ein anderes Element an Position 0 bringen und dieses
; wieder in Heap-Form bringen:
(let ((jj n))
(loop
(decf jj)
(unless (plusp jj) (return))
(rotatef (aref A 0) (aref A jj))
(adjust 0 jj)
) )
(coerce A 'list)
) ) )